perm filename COPYIT.F4[RST,LCS] blob
sn#206560 filedate 1976-03-14 generic text, type C, neo UTF8
COMMENT ā VALID 00002 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00002 00002 C***** COPYIT, UPDN, STFCH ****** (OUTLIM, GETPTS, MOVIT -ALL OLD)
C00008 ENDMK
Cā;
C***** COPYIT, UPDN, STFCH ****** (OUTLIM, GETPTS, MOVIT -ALL OLD)
SUBROUTINE COPYIT
INTEGER PWDS
COMMON/XRN/RN(4000) /KJY/ DONT,JY /POSI/S(8),JJ2,P
COMMON R2,JA,CENTR,J2,RJQ(18),RX6,JR,L,RDIS,VY,JQ(17)
1/PTR/PWDS(250),ITEM,LL,I,IX
EQUIVALENCE (R4,RJQ(2)),(R5,RJQ(3)),(R7,RJQ(5))
1,(R6,RJQ(4)),(N,RN(2500))
IM=ITEM
DO 1 K=1,IM
L=PWDS(K)
IF(RTLINE(L))GO TO 1
IF(OUTLIM(L,3))GO TO 1
IF(R6.NE.0.AND.R6.NE.RN(L+1))GO TO 1
M=RN(L)+2
CALL LOOP(0,M,1,I,L,RN)
ITEM=ITEM+1
L=PWDS(ITEM)
RN(L+2)=R7
IF(JJ2)JJ2=ITEM
I=I+M+1
PWDS(ITEM+1)=I
1 CONTINUE
R2=R7
END
SUBROUTINE STFCH
INTEGER PWDS
COMMON/XRN/RN(4000) /KJY/ DONT,JY /POSI/S(8),JJ2,P
COMMON R2,JA,CENTR,J2,RJQ(18),RX6,JR,L,RDIS,VY,JQ(17)
1/PTR/PWDS(250),ITEM,LL,I,IX
EQUIVALENCE (R4,RJQ(2)),(R5,RJQ(3)),(R7,RJQ(5))
1,(R6,RJQ(4))
DO 1 K=1,ITEM
L=PWDS(K)
IF(RTLINE(L))GO TO 1
IF(OUTLIM(L,3))GO TO 1
IF(RN(L+1).NE.R6.AND.R6.NE.0)GO TO 1
C DIDN'T MATCH THE CODE NUM.
IF(JJ2)JJ2=K
RN(L+2)=R7
1 CONTINUE
END
SUBROUTINE UPDN(NST)
INTEGER PWDS
COMMON/XRN/RN(4000) /KJY/ DONT,JY /POSI/S(8),JJ2,P
COMMON R2,JA,CENTR,J2,RJQ(18),RX6,JR,L,RDIS,VY,JQ(17)
1/PTR/PWDS(250),ITEM,LL,I,IX
EQUIVALENCE (R4,RJQ(2)),(R5,RJQ(3)),(R11,RJQ(9))
1,(R6,RJQ(4))
DO 1 K=NST,ITEM
L=PWDS(K)
IF(RTLINE(L))GO TO 1
RY=RN(L+1)
IF(RY.GT.16)GO TO 1
IF(RY.EQ.8)GO TO 1
IF(RY.EQ.3)GO TO 1
IF(RY.EQ.R6)GO TO 10
IF(R6.NE.0)GO TO 1
C DIDN'T MATCH THE CODE NUM.
10 IF(RY.NE.4)GO TO 11
IF(RN(L).LT.3)GO TO 1
C A BAR LINE
11 IF(OUTLIM(L,3))GO TO 2
RN(L+4)=RN(L+4)+R11
IF(JJ2)JJ2=K
2 IF(RY.LT.4)GO TO 1
IF(RY.GT.7)GO TO 1
IF(RY.EQ.7)GO TO 1
C NO WIGGLE ON TRILL
IF(RY.NE.4.)GO TO 12
IF(RN(L+5).EQ.50)GO TO 1
C CRESC. OR BOX
12 IF(OUTLIM(L,6))GO TO 1
RN(L+5)=RN(L+5)+R11
IF(JJ2)JJ2=K
1 CONTINUE
END
CF SUBROUTINE GETPTS
CF DIMENSION N(500),NP(500)
CF COMMON/XRN/RN(4000) /KJY/ K,J
CF COMMON R2,JA,CENTR,J2,RJQ(18),RX6,JR,L,RDIS,VY,JQ(17)
CF 1/PTR/PWDS(250),ITEM,LL,I,IX
CF EQUIVALENCE (R4,RJQ(2)),(R5,RJQ(3)),(R11,RJQ(9))
CF 1,(R6,RJQ(4)),(N,RN(2500)),(NP,RN(3000))
CF J=0
CF K=0
CF DO 1 M=1,ITEM
CF L=PWDS(M)
CF IF(RTLINE(L))GO TO 1
CF RY=RN(L+1)
CF IF(R6.LE.0)GO TO 9
C CHECK CODE NUM
CF IF(R6.NE.RY)GO TO 1
CF9 IF(OUTLIM(R4,R5,RN(L+3)))GO TO 2
C IN LIMITS?
CF IF(JJ2)JJ2=M **** ALSO AT 6,8 AND 5 ***
CF J=J+1
CF N(J)=L+3
CF K=K+1
CF NP(K)=L
C FOR USE IN JUSTIFY ROUTINE
CF2 IF(RY.LT.4)GO TO 1
CF IF(RY.GT.7)GO TO 1
C TWO-ENDED ITEM?
CF RZ=RN(L)
C WD CNT
CF GO TO(4,5,6,7),IFIX(RY)-3
CF4 IF(RZ.GT.2)GO TO 5
CF GO TO 1
CF7 IF(RZ.GT.4)GO TO 5
CF GO TO 1
CF6 IF(RZ.LT.8)GO TO 8
CF IF(RN(L+10).LT.30)GO TO 8
CF IF(OUTLIM(R4,R5,RN(L+8)))GO TO 8
CF J=J+1
CF N(J)=L+8
CF IF(RZ.LT.7)GO TO 5
CF IF(OUTLIM(R4,R5,RN(L+9)))GO TO 5
CF J=J+1
CF N(J)=L+9
CF5 IF(OUTLIM(R4,R5,RN(L+6)))GO TO 1
CF J=J+1
CF N(J)=L+6
CF1 CONTINUE
CF END
CF FUNCTION OUTLIM(A,B,C)
CF OUTLIM=-1
CF IF(C.LT.A)RETURN
CF IF(C.GT.B)RETURN
CF OUTLIM=0
CF END
CF SUBROUTINE MOVIT
CF DIMENSION N(500)
CF COMMON/XRN/RN(4000) /KJY/ DONT,J
CF COMMON R2,JA,CENTR,J2,RJQ(18),RX6,JR,L,RDIS,VY,JQ(17)
CF EQUIVALENCE (R4,RJQ(2)),(R5,RJQ(3)),(R9,RJQ(7))
CF 1,(R6,RJQ(4)),(N,RN(2500)),(R8,RJQ(6))
CF RDIS=(R9-R8)/(R5-R4)
CF DO 1 K=1,J
CF L=N(K)
CF RA=RN(L)
CF IF(OUTLIM(R4,R5,RA))GO TO 1
CF IF(R9.NE.0)RA=(RA-R4)*RDIS
CF RN(L)=R8+RA
CF1 CONTINUE
CF END